COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Chart Making program
C00004 00003	 The lines of a box are segments. So a Box would look like:
C00016 ENDMK
C⊗;
;;; Chart Making program
;;;	(...(benchmark 
;;;	     (impl1 entry1) (impl2 entry2)...) ...)
;;;
;;; For each benchmark:
;;;(...(benchmark
;;;     ((blankline))
;;;     ((indent 1) "Benchmark 3" (entry (f entry)))
;;;     ((center) "Random Text"))...)
;;;
;;; For each implementation:
;;;(...(impl "Top-row Information")...)


(declare (special *data* *benchmarks*))
(eval-when (compile) (fasload struct fas dsk (mac lsp)))

(defmacro string-length (str)
	  `(flatc ,str))

(defun lookup (bench impl)
       (cadr (assoc impl (cdr (assoc bench *data*)))))

(declare (special *benchmark-info*))

(defun get-bench-info (bench)
       (cdr (assoc bench *benchmark-info*)))
;;; The lines of a box are segments. So a Box would look like:
;;;	<blankline>
;;;	Division by 2
;;;	<blankline>
;;;	   Recursive
;;;	   Iterative
;;;	<blankline>

(declare (special *vertical-bar* *all-boxes* *total-width*))
(declare (mapex t))
(defmacro rpush (x y)
	  `(setf ,y (cons ,x ,y)))

(defun princ-n (char n)
 (break Princ-n (< n 0))
       (do ((n n (1- n)))
	   ((zerop n) t)
	   (princ char)))

(setq *vertical-bar* "|")

(defun id (() x) x)

(defstruct (box named)
	   (number-of-lines 0)
	   (width 0)
	   (lines ()))

;;; Each line is a LINE. We string Boxes together left-to-right to make
;;; a slice of the row. We paste Rows together to make the chart

(defstruct (line named)
	   (text ())
	   (pre-spaces '?)
	   (post-spaces '?)
	   (text-length '?))

(defun format-box (box)
       (let ((width (width box)))
	    (mapc #'(lambda (line)
			    (let ((tl (text-length line)))
			    (cond ((eq (pre-spaces line) '?)
				   (let ((n (// (- width tl) 2)))
					(setf (pre-spaces line) n)
					(setf (post-spaces line) 
					      (- (- width tl) n))))
				  ((eq (post-spaces line) '?)
				   (setf (post-spaces line)
					   (- width (+ tl
						       (pre-spaces line))))))))
		  (lines box))
	    t)))

(defstruct (row named)
	   (boxes ())
	   (width 0)
	   (row-type 'normal))

(defstruct (chart named)
	   (rows ()))

(defun make-a-chart (implementations)
       (let ((chart
	      (make-chart
	       rows
	       `(,(make-top-row implementations)
		 ,@(mapcan #'(lambda (bench)
				     (list (make-dashed-row)
					   (make-a-row bench implementations)))
			   *benchmarks*)
		 ,(make-dashed-row)))))
	    (assign-widths chart)
	    (find-total-width chart)
	    (format-all-boxes)
	    (find-total-width chart)
	    (print-chart chart)))

(defun make-top-row (implementations)
       (make-a-row 'Title implementations))

(defun make-dashed-row ()
       (make-row
	row-type 'dashed
	boxes
	(let ((box (make-box
		    number-of-lines 1
		    lines
		    `(,(make-line
			text-length 0)))))
	     `(,box))))

(defun make-a-row (bench implementations)
 (let* ((info
	 (get-bench-info bench))
	(len (length info)))
  (make-row
   boxes
   `(,(let ((box 
	     (make-box
	      number-of-lines len)))
	   (push box *all-boxes*)
	   (setf (lines box)
		 (mapcar #'(lambda (line)
				   (caseq (caar line)
					  (blankline
					   (make-line
					    text-length 0))
					  (center
					   (setf (width box)
						 (max (width box)
						      (+ 2 (string-length
							    (cadr line)))))
					   (make-line
					    text-length
					    (string-length (cadr line))
					    text (cadr line)))
					  (indent
					   (setf (width box)
						 (max (width box)
						      (+
						       (cadr (car line))
						       (+ 2 (string-length
							     (cadr line))))))
					   (make-line
					    pre-spaces (cadr (car line))
					    text-length
					    (string-length (cadr line))
					    text (cadr line)))
					  (t (error "Bad Format in Left Column"))))
			 info))
	   box)
     ,(let ((box (make-box
		  number-of-lines len
		  width 1
		  lines
		  (mapcar #'(lambda (())
				    (make-line
				     text-length 1
				     text *vertical-bar*
				     pre-spaces 0
				     post-spaces 0))
			  info))))
	   (push box *all-boxes*)
	   box)
       ,@(mapcan
	  #'(lambda (impl)
		    (let ((entry
			   (cond ((atom impl)
				  (lookup bench impl))
				 (t (or (lookup bench impl)
					(mapcar #'(lambda (x)
							  (lookup bench x))
      						(cdr impl)))))))
           		 (list 
			  (let ((box
				 (make-box
				  number-of-lines len)))
			       (push box *all-boxes*)
			       (setf (lines box)
				     (mapcar 
				      #'(lambda (line)
					 (caseq (caaddr line)
						(entry
            					 (let ((item
							(cond ((or (atom impl)
								   (atom entry))
							       (funcall (cadr (caddr line))
									impl entry))
							      (t 
           						       (apply
								(car impl)
								(mapcar 
								 #'(lambda 
								    (x y)
           							    (funcall 
								     (cadr 
								      (caddr line))
								     x y))
								 (cdr impl)
								 entry))))))
           					      (let ((wd
							     (cond 
							      ((null item)
							       (setq item "-")
							       1)
							      ((eq (typep item) 'symbol)
							       (flatc item)) 
							      (t (flatsize item)))))
						      (setf (width box)
							    (max (+ 2 wd)
								 (width box)))
						      (make-line
						       text-length wd
						       text item))))
						(t (make-line
						    text-length 0))))
				      info))
			       box)
			  (let ((box 
				 (make-box
				  number-of-lines len
				  width 1
				  lines
				  (mapcar #'(lambda (())
						    (make-line
						     text-length 1
						     text *vertical-bar*
						     pre-spaces 0
						     post-spaces 0))
					  info))))
			       (push box *all-boxes*)
			       box))))
	  implementations)))
  )))

 (defun assign-widths (chart)
	(let ((columns
	       (mapcar #'(lambda (())
				 ())
		       (boxes (car (rows chart))))))
	     (do ((rows (rows chart) (cdr rows)))
		 ((null rows))
		 (caseq (row-type (car rows))
			(normal
			 (do ((cols columns (cdr cols))
			      (boxes (boxes (car rows)) (cdr boxes)))
			     ((null boxes))
			     (rpush (car boxes) (car cols))))
			))
	     (mapcar
	      #'(lambda (col)
			(let ((maximum 0))
			     (mapc
			      #'(lambda (box)
					(setq maximum
					      (max maximum
						   (width box))))
			      col)
			     (mapc
			      #'(lambda (box)
					(setf (width box) maximum))
			      col)))
	      columns))
	t)

(defun format-all-boxes ()
       (mapc #'format-box *all-boxes*))

(defun find-total-width (chart)
       (setq *total-width* 0)
       (mapc #'(lambda (box)
		       (setq *total-width*
			     (+ *total-width*
				(width box))))
	     (boxes (car (rows chart))))
       t))

(defun print-chart (chart)
       (mapc #'print-row (rows chart))
       t)

(defun print-row (row)
       (terpri)
       (cond ((eq (row-type row) 'dashed)
	      (princ-n "-" (1- *total-width*)) (princ *vertical-bar*))
	     (t 
	      (print-boxes (boxes row))))
       t) 

(defun print-boxes (boxes)
       (let ((n (number-of-lines (car boxes))))
	    (do ((i 0 (1+ i)))
		((= i n))
		(terpri)
		(print-line-n boxes i))))

(defun print-line-n (boxes n)
       (mapc #'(lambda (box)
		       (print-line (nth n (lines box))))
	     boxes)
       t)

(defun print-line (line)
       (princ-n " " (pre-spaces line))
       (or (zerop (text-length line))
	   (princ (text line)))
       (princ-n " " (post-spaces line))
       t)

(defun do-chart (implementations)
       (setq *all-boxes* ()
	     *total-width* 0)
       (make-a-chart
	implementations))